home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / ExtUtils / Constant.pm < prev    next >
Encoding:
Perl POD Document  |  2006-04-25  |  13.2 KB  |  516 lines
  1. package ExtUtils::Constant;
  2. use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
  3. $VERSION = 0.16;
  4.  
  5. =head1 NAME
  6.  
  7. ExtUtils::Constant - generate XS code to import C header constants
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.     use ExtUtils::Constant qw (WriteConstants);
  12.     WriteConstants(
  13.         NAME => 'Foo',
  14.         NAMES => [qw(FOO BAR BAZ)],
  15.     );
  16.     # Generates wrapper code to make the values of the constants FOO BAR BAZ
  17.     #  available to perl
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. ExtUtils::Constant facilitates generating C and XS wrapper code to allow
  22. perl modules to AUTOLOAD constants defined in C library header files.
  23. It is principally used by the C<h2xs> utility, on which this code is based.
  24. It doesn't contain the routines to scan header files to extract these
  25. constants.
  26.  
  27. =head1 USAGE
  28.  
  29. Generally one only needs to call the C<WriteConstants> function, and then
  30.  
  31.     #include "const-c.inc"
  32.  
  33. in the C section of C<Foo.xs>
  34.  
  35.     INCLUDE: const-xs.inc
  36.  
  37. in the XS section of C<Foo.xs>.
  38.  
  39. For greater flexibility use C<constant_types()>, C<C_constant> and
  40. C<XS_constant>, with which C<WriteConstants> is implemented.
  41.  
  42. Currently this module understands the following types. h2xs may only know
  43. a subset. The sizes of the numeric types are chosen by the C<Configure>
  44. script at compile time.
  45.  
  46. =over 4
  47.  
  48. =item IV
  49.  
  50. signed integer, at least 32 bits.
  51.  
  52. =item UV
  53.  
  54. unsigned integer, the same size as I<IV>
  55.  
  56. =item NV
  57.  
  58. floating point type, probably C<double>, possibly C<long double>
  59.  
  60. =item PV
  61.  
  62. NUL terminated string, length will be determined with C<strlen>
  63.  
  64. =item PVN
  65.  
  66. A fixed length thing, given as a [pointer, length] pair. If you know the
  67. length of a string at compile time you may use this instead of I<PV>
  68.  
  69. =item SV
  70.  
  71. A B<mortal> SV.
  72.  
  73. =item YES
  74.  
  75. Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
  76.  
  77. =item NO
  78.  
  79. Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
  80.  
  81. =item UNDEF
  82.  
  83. C<undef>.  The value of the macro is not needed.
  84.  
  85. =back
  86.  
  87. =head1 FUNCTIONS
  88.  
  89. =over 4
  90.  
  91. =cut
  92.  
  93. if ($] >= 5.006) {
  94.   eval "use warnings; 1" or die $@;
  95. }
  96. use strict;
  97. use Carp qw(croak cluck);
  98.  
  99. use Exporter;
  100. use ExtUtils::Constant::Utils qw(C_stringify);
  101. use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
  102.  
  103. @ISA = 'Exporter';
  104.  
  105. %EXPORT_TAGS = ( 'all' => [ qw(
  106.     XS_constant constant_types return_clause memEQ_clause C_stringify
  107.     C_constant autoload WriteConstants WriteMakefileSnippet
  108. ) ] );
  109.  
  110. @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  111.  
  112. =item constant_types
  113.  
  114. A function returning a single scalar with C<#define> definitions for the
  115. constants used internally between the generated C and XS functions.
  116.  
  117. =cut
  118.  
  119. sub constant_types {
  120.   ExtUtils::Constant::XS->header();
  121. }
  122.  
  123. sub memEQ_clause {
  124.   cluck "ExtUtils::Constant::memEQ_clause is deprecated";
  125.   ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
  126.                     indent=>$_[2]});
  127. }
  128.  
  129. sub return_clause ($$) {
  130.   cluck "ExtUtils::Constant::return_clause is deprecated";
  131.   my $indent = shift;
  132.   ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
  133. }
  134.  
  135. sub switch_clause {
  136.   cluck "ExtUtils::Constant::switch_clause is deprecated";
  137.   my $indent = shift;
  138.   my $comment = shift;
  139.   ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
  140.                     @_);
  141. }
  142.  
  143. sub C_constant {
  144.   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
  145.     = @_;
  146.   ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
  147.                       default_type => $default_type,
  148.                       types => $what, indent => $indent,
  149.                       breakout => $breakout}, @items);
  150. }
  151.  
  152. =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
  153.  
  154. A function to generate the XS code to implement the perl subroutine
  155. I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
  156. This XS code is a wrapper around a C subroutine usually generated by
  157. C<C_constant>, and usually named C<constant>.
  158.  
  159. I<TYPES> should be given either as a comma separated list of types that the
  160. C subroutine C<constant> will generate or as a reference to a hash. It should
  161. be the same list of types as C<C_constant> was given.
  162. [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
  163. the number of parameters passed to the C function C<constant>]
  164.  
  165. You can call the perl visible subroutine something other than C<constant> if
  166. you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
  167. the name of the perl visible subroutine, unless you give the parameter
  168. I<C_SUBNAME>.
  169.  
  170. =cut
  171.  
  172. sub XS_constant {
  173.   my $package = shift;
  174.   my $what = shift;
  175.   my $subname = shift;
  176.   my $C_subname = shift;
  177.   $subname ||= 'constant';
  178.   $C_subname ||= $subname;
  179.  
  180.   if (!ref $what) {
  181.     # Convert line of the form IV,UV,NV to hash
  182.     $what = {map {$_ => 1} split /,\s*/, ($what)};
  183.   }
  184.   my $params = ExtUtils::Constant::XS->params ($what);
  185.   my $type;
  186.  
  187.   my $xs = <<"EOT";
  188. void
  189. $subname(sv)
  190.     PREINIT:
  191. #ifdef dXSTARG
  192.     dXSTARG; /* Faster if we have it.  */
  193. #else
  194.     dTARGET;
  195. #endif
  196.     STRLEN        len;
  197.         int        type;
  198. EOT
  199.  
  200.   if ($params->{IV}) {
  201.     $xs .= "    IV        iv;\n";
  202.   } else {
  203.     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
  204.   }
  205.   if ($params->{NV}) {
  206.     $xs .= "    NV        nv;\n";
  207.   } else {
  208.     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
  209.   }
  210.   if ($params->{PV}) {
  211.     $xs .= "    const char    *pv;\n";
  212.   } else {
  213.     $xs .=
  214.       "    /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
  215.   }
  216.  
  217.   $xs .= << 'EOT';
  218.     INPUT:
  219.     SV *        sv;
  220.         const char *    s = SvPV(sv, len);
  221. EOT
  222.   if ($params->{''}) {
  223.   $xs .= << 'EOT';
  224.     INPUT:
  225.     int        utf8 = SvUTF8(sv);
  226. EOT
  227.   }
  228.   $xs .= << 'EOT';
  229.     PPCODE:
  230. EOT
  231.  
  232.   if ($params->{IV} xor $params->{NV}) {
  233.     $xs .= << "EOT";
  234.         /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
  235.            if you need to return both NVs and IVs */
  236. EOT
  237.   }
  238.   $xs .= "    type = $C_subname(aTHX_ s, len";
  239.   $xs .= ', utf8' if $params->{''};
  240.   $xs .= ', &iv' if $params->{IV};
  241.   $xs .= ', &nv' if $params->{NV};
  242.   $xs .= ', &pv' if $params->{PV};
  243.   $xs .= ', &sv' if $params->{SV};
  244.   $xs .= ");\n";
  245.  
  246.   $xs .= << "EOT";
  247.       /* Return 1 or 2 items. First is error message, or undef if no error.
  248.            Second, if present, is found value */
  249.         switch (type) {
  250.         case PERL_constant_NOTFOUND:
  251.           sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
  252.           PUSHs(sv);
  253.           break;
  254.         case PERL_constant_NOTDEF:
  255.           sv = sv_2mortal(newSVpvf(
  256.         "Your vendor has not defined $package macro %s, used", s));
  257.           PUSHs(sv);
  258.           break;
  259. EOT
  260.  
  261.   foreach $type (sort keys %XS_Constant) {
  262.     # '' marks utf8 flag needed.
  263.     next if $type eq '';
  264.     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
  265.       unless $what->{$type};
  266.     $xs .= "        case PERL_constant_IS$type:\n";
  267.     if (length $XS_Constant{$type}) {
  268.       $xs .= << "EOT";
  269.           EXTEND(SP, 1);
  270.           PUSHs(&PL_sv_undef);
  271.           $XS_Constant{$type};
  272. EOT
  273.     } else {
  274.       # Do nothing. return (), which will be correctly interpreted as
  275.       # (undef, undef)
  276.     }
  277.     $xs .= "          break;\n";
  278.     unless ($what->{$type}) {
  279.       chop $xs; # Yes, another need for chop not chomp.
  280.       $xs .= " */\n";
  281.     }
  282.   }
  283.   $xs .= << "EOT";
  284.         default:
  285.           sv = sv_2mortal(newSVpvf(
  286.         "Unexpected return type %d while processing $package macro %s, used",
  287.                type, s));
  288.           PUSHs(sv);
  289.         }
  290. EOT
  291.  
  292.   return $xs;
  293. }
  294.  
  295.  
  296. =item autoload PACKAGE, VERSION, AUTOLOADER
  297.  
  298. A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
  299. I<VERSION> is the perl version the code should be backwards compatible with.
  300. It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
  301. is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
  302. names that the constant() routine doesn't recognise.
  303.  
  304. =cut
  305.  
  306. # ' # Grr. syntax highlighters that don't grok pod.
  307.  
  308. sub autoload {
  309.   my ($module, $compat_version, $autoloader) = @_;
  310.   $compat_version ||= $];
  311.   croak "Can't maintain compatibility back as far as version $compat_version"
  312.     if $compat_version < 5;
  313.   my $func = "sub AUTOLOAD {\n"
  314.   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
  315.   . "    # XS function.";
  316.   $func .= "  If a constant is not found then control is passed\n"
  317.   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
  318.  
  319.  
  320.   $func .= "\n\n"
  321.   . "    my \$constname;\n";
  322.   $func .=
  323.     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
  324.  
  325.   $func .= <<"EOT";
  326.     (\$constname = \$AUTOLOAD) =~ s/.*:://;
  327.     croak "&${module}::constant not defined" if \$constname eq 'constant';
  328.     my (\$error, \$val) = constant(\$constname);
  329. EOT
  330.  
  331.   if ($autoloader) {
  332.     $func .= <<'EOT';
  333.     if ($error) {
  334.     if ($error =~  /is not a valid/) {
  335.         $AutoLoader::AUTOLOAD = $AUTOLOAD;
  336.         goto &AutoLoader::AUTOLOAD;
  337.     } else {
  338.         croak $error;
  339.     }
  340.     }
  341. EOT
  342.   } else {
  343.     $func .=
  344.       "    if (\$error) { croak \$error; }\n";
  345.   }
  346.  
  347.   $func .= <<'END';
  348.     {
  349.     no strict 'refs';
  350.     # Fixed between 5.005_53 and 5.005_61
  351. #XXX    if ($] >= 5.00561) {
  352. #XXX        *$AUTOLOAD = sub () { $val };
  353. #XXX    }
  354. #XXX    else {
  355.         *$AUTOLOAD = sub { $val };
  356. #XXX    }
  357.     }
  358.     goto &$AUTOLOAD;
  359. }
  360.  
  361. END
  362.  
  363.   return $func;
  364. }
  365.  
  366.  
  367. =item WriteMakefileSnippet
  368.  
  369. WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 
  370.  
  371. A function to generate perl code for Makefile.PL that will regenerate
  372. the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
  373. with the addition of C<INDENT> to specify the number of leading spaces
  374. (default 2).
  375.  
  376. Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
  377. C<XS_FILE> are recognised.
  378.  
  379. =cut
  380.  
  381. sub WriteMakefileSnippet {
  382.   my %args = @_;
  383.   my $indent = $args{INDENT} || 2;
  384.  
  385.   my $result = <<"EOT";
  386. ExtUtils::Constant::WriteConstants(
  387.                                    NAME         => '$args{NAME}',
  388.                                    NAMES        => \\\@names,
  389.                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
  390. EOT
  391.   foreach (qw (C_FILE XS_FILE)) {
  392.     next unless exists $args{$_};
  393.     $result .= sprintf "                                   %-12s => '%s',\n",
  394.       $_, $args{$_};
  395.   }
  396.   $result .= <<'EOT';
  397.                                 );
  398. EOT
  399.  
  400.   $result =~ s/^/' 'x$indent/gem;
  401.   return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
  402.                          indent=>$indent,},
  403.                         @{$args{NAMES}})
  404.     . $result;
  405. }
  406.  
  407. =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
  408.  
  409. Writes a file of C code and a file of XS code which you should C<#include>
  410. and C<INCLUDE> in the C and XS sections respectively of your module's XS
  411. code.  You probably want to do this in your C<Makefile.PL>, so that you can
  412. easily edit the list of constants without touching the rest of your module.
  413. The attributes supported are
  414.  
  415. =over 4
  416.  
  417. =item NAME
  418.  
  419. Name of the module.  This must be specified
  420.  
  421. =item DEFAULT_TYPE
  422.  
  423. The default type for the constants.  If not specified C<IV> is assumed.
  424.  
  425. =item BREAKOUT_AT
  426.  
  427. The names of the constants are grouped by length.  Generate child subroutines
  428. for each group with this number or more names in.
  429.  
  430. =item NAMES
  431.  
  432. An array of constants' names, either scalars containing names, or hashrefs
  433. as detailed in L<"C_constant">.
  434.  
  435. =item C_FILE
  436.  
  437. The name of the file to write containing the C code.  The default is
  438. C<const-c.inc>.  The C<-> in the name ensures that the file can't be
  439. mistaken for anything related to a legitimate perl package name, and
  440. not naming the file C<.c> avoids having to override Makefile.PL's
  441. C<.xs> to C<.c> rules.
  442.  
  443. =item XS_FILE
  444.  
  445. The name of the file to write containing the XS code.  The default is
  446. C<const-xs.inc>.
  447.  
  448. =item SUBNAME
  449.  
  450. The perl visible name of the XS subroutine generated which will return the
  451. constants. The default is C<constant>.
  452.  
  453. =item C_SUBNAME
  454.  
  455. The name of the C subroutine generated which will return the constants.
  456. The default is I<SUBNAME>.  Child subroutines have C<_> and the name
  457. length appended, so constants with 10 character names would be in
  458. C<constant_10> with the default I<XS_SUBNAME>.
  459.  
  460. =back
  461.  
  462. =cut
  463.  
  464. sub WriteConstants {
  465.   my %ARGS =
  466.     ( # defaults
  467.      C_FILE =>       'const-c.inc',
  468.      XS_FILE =>      'const-xs.inc',
  469.      SUBNAME =>      'constant',
  470.      DEFAULT_TYPE => 'IV',
  471.      @_);
  472.  
  473.   $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
  474.  
  475.   croak "Module name not specified" unless length $ARGS{NAME};
  476.  
  477.   open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
  478.   open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
  479.  
  480.   # As this subroutine is intended to make code that isn't edited, there's no
  481.   # need for the user to specify any types that aren't found in the list of
  482.   # names.
  483.   my $types = {};
  484.  
  485.   print $c_fh constant_types(); # macro defs
  486.   print $c_fh "\n";
  487.  
  488.   # indent is still undef. Until anyone implements indent style rules with it.
  489.   foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
  490.                            subname => $ARGS{C_SUBNAME},
  491.                            default_type =>
  492.                            $ARGS{DEFAULT_TYPE},
  493.                            types => $types,
  494.                            breakout => $ARGS{BREAKOUT_AT}},
  495.                            @{$ARGS{NAMES}})) {
  496.     print $c_fh $_, "\n"; # C constant subs
  497.   }
  498.   print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
  499.                             $ARGS{C_SUBNAME});
  500.  
  501.   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
  502.   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
  503. }
  504.  
  505. 1;
  506. __END__
  507.  
  508. =back
  509.  
  510. =head1 AUTHOR
  511.  
  512. Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  513. others
  514.  
  515. =cut
  516.